home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / load_comex.t < prev    next >
Text File  |  1988-02-05  |  8KB  |  204 lines
  1. (herald load_comex
  2.         (env tsys (osys retrieve)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Operations on loaded files.
  28. ;;; Loaded-file is a subtype of compiled-code, at least for now.
  29.  
  30. (define-operation (loaded-file-source loaded-file)) ;returns a filename or #f
  31. (define-operation (loaded-file-herald loaded-file)) ;always returns a herald
  32.  
  33. (define-operation (run-compiled-code code env))
  34. (define-operation (relocate-compiled-code code env))
  35. (define-predicate compiled-code?)
  36.  
  37. ;;; Compiled expressions
  38.  
  39. ;++ this should have a target-machine and a target-os field.
  40. (define-structure-type comex
  41.   module-name
  42.   code                  ;Code vector (probably a byte vector)
  43.   objects               ;General vector of interesting objects
  44.   opcodes               ;Byte vector of things to do with the objects
  45. ;++  target-cpu
  46. ;++  target-os
  47.   annotation)
  48.  
  49. ;;; The OBJECTS and OPCODES vectors are in 1-1 correspondence.  Each
  50. ;;; opcode describes what should be done with the corresponding
  51. ;;; object.  The result of processing an object/opcode pair gets
  52. ;;; stored at the corresponding position when the closure ("unit")
  53. ;;; is being created.
  54.  
  55. ;;; (define (run-compiled-code comex env)
  56. ;;;   ((map-vector (lambda (op obj)
  57. ;;;                  ((vref *op-procedures* op) obj env))
  58. ;;;                (comex-objects comex)
  59. ;;;                (comex-opcodes comex))))
  60.  
  61.  
  62. (define (dump-keys obj)
  63.   (if (comex? obj) 'comex nil))
  64.  
  65. (define (dump-accessors sym)
  66.   (xcase sym
  67.          ((comex) (stype-selectors comex-stype))))
  68.  
  69. (define (dump-makers sym)
  70.   (xcase sym
  71.          ((comex) make-comex)))
  72.  
  73. (define (comex-decoder key)
  74.   (case key
  75.     ((comex) (return make-comex (stype-selectors comex-stype)))
  76.     (else    (return nil nil))))
  77.  
  78. ;++ flush this
  79. (define (read-comex-from-file spec)
  80.   (with-open-ports ((s (open spec 'retrieve)))
  81.     (if (fx= (retrieve-port-magic-number s) retrieve-magic-number)
  82.         (set-decoder s comex-decoder)
  83.         (error "bad magic dump number in ~S" spec))
  84.     (read s)))
  85.  
  86. (define (read-comex port)
  87.   (let* ((magic (get-bytes port 4))
  88.          (comex (cond ((fx= magic retrieve-magic-number)
  89.                        (let ((port (make-retrieve port)))
  90.                          (set-decoder port comex-decoder)
  91.                          (read port)))
  92.                       (else
  93.                        (error "bad magic dump number in ~S" port)))))
  94. ;++ flush
  95. ;                     (else
  96. ;                      (warning "obsolete dump file ~A~%"
  97. ;                               (port-name port))
  98. ;                      (close-port port)
  99. ;                      (re-open-port! port 'in)
  100. ;                      ;++ check for old magic number later
  101. ;                      (let ((port (make-old-retrieve port)))
  102. ;                        (set-decoders port dump-makers dump-accessors)
  103. ;                        (read port))))))
  104.     ;++(let ((name (port-name port)))
  105.     ;++  (if name (set (table-entry loaded-file-table name) comex)))
  106.     comex
  107.     ;++ what about the balancing #\]
  108.     ))
  109.  
  110. (define (load-comex port env)
  111.   (receive (unit code) (install-comex (read-comex port) env)
  112.     (set (weak-table-entry code-unit-table code) unit)
  113.     (add-to-population code-population code)
  114.     ;; run top-level forms
  115.     ((unit-top-level-forms unit))))
  116.  
  117. ;++ check that target cpu and os are ok.
  118. (define (install-comex comex env)
  119.   (let* ((opcodes (comex-opcodes comex))
  120.          (unit    (comex-objects comex))
  121.          (elts    (vector-length unit))
  122.          (code    (comex-code    comex)))
  123.     (vector->unit! unit)
  124.     (set (unit-env unit) env)        
  125.     (do ((i (fx- elts 1) (fx- i 1)))
  126.         ((fx< i 0)                                                       
  127.          (adjust-unit-names unit)
  128.          (purify! code)
  129.          (return unit code))
  130.       (let ((obj (extend-elt unit i)))
  131.         (xselect (bref opcodes i)
  132.           ((op/literal)                                      
  133.            ;++ compiler bug
  134.            (if (and (string? obj) (not (pure? (string-text obj))))
  135.                (purify! (string-text obj)))
  136.            (set (extend-elt unit i) obj))
  137.           ((op/foreign)            
  138.            (set (extend-elt unit i) (make-foreign-procedure obj)))
  139.           ((op/closure)                   
  140.            (set (extend-elt unit i)  ; obj is code-vector-offset
  141.                 (make-pointer code (fixnum-ashr obj 2))))
  142.           ((op/template1)                                     
  143.            (install-template1 unit code obj i))
  144.           ((op/template2 op/template3))
  145.           ((op/vcell-stored-definition)
  146.            (let ((vcell (env-lookup env (car obj) t t)))
  147.              (check-rebinding vcell t install-comex)
  148.              (weak-alist-push! (vcell-vcell-locations vcell) unit i)
  149.          (distribute-vcells vcell)
  150.              (*set vcell (make-pointer unit 
  151.                        (fx- (fixnum-ashr (cdr obj) 2) 1)))))
  152.           ((op/vcell-defined)
  153.            (let ((vcell (env-lookup env obj t t)))
  154.              (check-rebinding vcell t install-comex)
  155.              (weak-alist-push! (vcell-vcell-locations vcell) unit i)
  156.          (distribute-vcells vcell)))
  157.       ((op/vcell-lset)
  158.            (let ((vcell (env-lookup env obj t t)))
  159.              (check-rebinding vcell nil install-comex)
  160.              (weak-alist-push! (vcell-vcell-locations vcell) unit i)
  161.          (distribute-vcells vcell)))
  162.           ((op/vcell)
  163.            (let ((vcell (env-lookup env obj nil t)))
  164. ;             (check-rebinding vcell nil install-comex)
  165.              (weak-alist-push! (vcell-vcell-locations vcell) unit i)
  166.          (set (extend-elt unit i) vcell)))
  167.           ((op/variable-value)
  168.            (let ((vcell (env-lookup env obj nil t)))
  169.              (weak-alist-push! (vcell-locations vcell) unit i)
  170.          (set (mref-8-u vcell -2) -1)
  171.          (let ((value (vcell-contents vcell)))
  172.            (set (extend-elt unit i)
  173.             (make-link-snapper (if (nonvalue? value) obj value)
  174.                        unit
  175.                        i))))))))))
  176.           
  177. (define (adjust-unit-names unit)
  178.   (cond ((file-system-present?)
  179.          (let ((h (unit-herald unit))
  180.                (s (unit-source-filename unit)))
  181.            (if (not (herald? h))
  182.                (set (unit-herald unit) (parse-herald (car h) (cdr h))))
  183.            (if (not (filename? s))
  184.                (set (unit-source-filename unit)
  185.                     (apply make-filename s))))))
  186.   (no-value))
  187.  
  188. ;++ This population is currently used only by the GC.  We should
  189. ;++ change the GC to use the CODE-UNIT-TABLE
  190. (define code-population (make-population 'code-population))
  191.  
  192. ;;; Initialize *CODE-UNIT-TABLE*.  Weak tables must be available
  193. ;;; before this procedure is called.
  194.  
  195. ;++ is the code-unit map really necessary?
  196. (define code-unit-table
  197.   (let ((table  (make-weak-table 'code-unit-table)))
  198.     (walk (lambda (arg)
  199.             (let ((code (car arg))
  200.                   (unit (cdr arg)))
  201.               (set (weak-table-entry table code) unit)))
  202.             *code-unit-map*)
  203.     table))
  204.